home *** CD-ROM | disk | FTP | other *** search
/ L' Effet Pommier 3 / L'Effet Pommier - Volume 03.iso / Programmation / Alpha ƒ / Tcl / SystemCode / library.tcl < prev    next >
Text File  |  1994-08-09  |  5KB  |  179 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # $Header: /rel/cvsfiles/devo/tcl/library/init.tcl,v 1.2 1992/12/23 15:39:29 zoo Exp $ SPRITE (Berkeley)
  7. #
  8. # Copyright 1991-1992 Regents of the University of California
  9. # Permission to use, copy, modify, and distribute this
  10. # software and its documentation for any purpose and without
  11. # fee is hereby granted, provided that this copyright
  12. # notice appears in all copies.  The University of California
  13. # makes no representations about the suitability of this
  14. # software for any purpose.  It is provided "as is" without
  15. # express or implied warranty.
  16. #
  17.  
  18. # unknown:
  19. # Invoked when a Tcl command is invoked that doesn't exist in the
  20. # interpreter:
  21. #
  22. #    1. See if the autoload facility can locate the command in a
  23. #       Tcl script file.  If so, load it and execute it.
  24. #    2. See if the command exists as an executable UNIX program.
  25. #       If so, "exec" the command.
  26. #    3. If the command was invoked at top-level:
  27. #        (a) see if the command requests csh-like history substitution
  28. #        in one of the common forms !!, !<number>, or ^old^new.  If
  29. #        so, emulate csh's history substitution.
  30. #        (b) see if the command is a unique abbreviation for another
  31. #        command.  If so, invoke the command.
  32.  
  33. proc unknown args {
  34.     global auto_noload env unknown_pending;
  35.  
  36.     set name [lindex $args 0]
  37.     if ![info exists auto_noload] {
  38.         #
  39.         # Make sure we're not trying to load the same proc twice.
  40.         #
  41.         if [info exists unknown_pending($name)] {
  42.             unset unknown_pending($name)
  43.             if ![array size unknown_pending] {
  44.                 unset unknown_pending
  45.             }
  46.             error "self-referential recursion in \"unknown\" for command \"$name\"";
  47.         }
  48.         set unknown_pending($name) pending;
  49.         set ret [auto_load $name];
  50.         unset unknown_pending($name);
  51.         if ![array size unknown_pending] {
  52.             unset unknown_pending
  53.         }
  54.         if $ret {
  55.             return [uplevel $args]
  56.         }
  57.     }
  58.  
  59.     if {([info level] == 1) && ([info script] == "")} {
  60.         if {$name == "!!"} {
  61.             return [uplevel {history redo}]
  62.         }
  63.         if [regexp {^!(.+)$} $name dummy event] {
  64.             return [uplevel history redo $event]
  65.         }
  66.         if [regexp {^\^(.*)\^(.*)^?$} $name dummy old new] {
  67.             return [uplevel history substitute $old $new]
  68.         }
  69.         set cmds [info commands $name*]
  70.         if {[llength $cmds] == 1} {
  71.             return [uplevel [lreplace $args 0 0 $cmds]]
  72.         }
  73.         if {[llength $cmds] != 0} {
  74.             if {$name == ""} {
  75.                 error "empty command name \"\""
  76.             } else {
  77.                 error "ambiguous command name \"$name\": [lsort $cmds]"
  78.             }
  79.         }
  80.     }
  81.     error "invalid command name \"$name\""
  82. }
  83.  
  84. # auto_load:
  85. # Checks a collection of library directories to see if a procedure
  86. # is defined in one of them.  If so, it sources the appropriate
  87. # library file to create the procedure.  Returns 1 if it successfully
  88. # loaded the procedure, 0 otherwise.
  89.  
  90. proc auto_load cmd {
  91.     global auto_index auto_oldpath auto_path env
  92.  
  93.     if [info exists auto_index($cmd)] {
  94.         uplevel #0 source [list $auto_index($cmd)]
  95.         return 1
  96.     }
  97.     if [catch {set path $auto_path}] {
  98.         if [catch {set path $env(TCLLIBPATH)}] {
  99.             if [catch {set path [info library]}] {
  100.                 return 0
  101.             }
  102.         }
  103.     }
  104.     if [info exists auto_oldpath] {
  105.         if {$auto_oldpath == $path} {
  106.             return 0
  107.         }
  108.     }
  109.     set auto_oldpath $path
  110.     catch {unset auto_index}
  111.     foreach dir $path {
  112.         source $dir:tclIndex
  113.     }
  114.     if [info exists auto_index($cmd)] {
  115.         uplevel #0 source [list $auto_index($cmd)]
  116.         return 1
  117.     }
  118.     return 0
  119. }
  120.  
  121. # auto_reset:
  122. # Destroy all cached information for auto-loading and auto-execution,
  123. # so that the information gets recomputed the next time it's needed.
  124. # Also delete any procedures that are listed in the auto-load index
  125. # except those related to auto-loading.
  126.  
  127. proc auto_reset {} {
  128.     global auto_execs auto_index auto_oldpath
  129.     foreach p [info procs] {
  130.         if {[info exists auto_index($p)] && ($p != "unknown")
  131.             && ![string match auto_* $p]} {
  132.             rename $p {}
  133.         }
  134.     }
  135.     catch {unset auto_execs}
  136.     catch {unset auto_index}
  137.     catch {unset auto_oldpath}
  138. }
  139.  
  140. # auto_mkindex:
  141. # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  142. # the name of the directory in which the tclIndex file is to be placed,
  143. # and a glob pattern to use in that directory to locate all of the relevant
  144. # files.
  145.  
  146. proc auto_mkindex {dir files} {
  147.     global errorCode errorInfo
  148.     set oldDir [pwd]
  149.     cd $dir
  150.     append index "# Tcl autoload index file: each line identifies a Tcl\n"
  151.     append index "# procedure and the file where that procedure is\n"
  152.     append index "# defined.  Generated by the \"auto_mkindex\" command.\n"
  153.     append index "\n"
  154.     foreach file [glob $files] {
  155.         watchCursor
  156.         set f ""
  157.         set error [catch {
  158.             set f [open $file]
  159.             while {[gets $f line] >= 0} {
  160.                 if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  161.                     append index "set auto_index($procName) \"\$dir:$file\"\n"
  162.                 }
  163.             }
  164.             close $f
  165.         } msg]
  166.         if $error {
  167.             set code $errorCode
  168.             set info $errorInfo
  169.             catch [close $f]
  170.             cd $oldDir
  171.             error $msg $info $code
  172.         }
  173.     }
  174.     set f [open tclIndex w]
  175.     puts $f $index nonewline
  176.     close $f
  177.     cd $oldDir
  178. }
  179.